#lang racket


(require "../base/main.rkt")
(require "../backends/main.rkt")

(require (prefix-in com: "rh-com.rkt")
         (prefix-in script: "rh-rhinoscript.rkt")
         "rh-shape.rkt")

(provide (rename-out (com:load-rhino-com load-rhino-marshall))
         
         ; constants
         (rename-out (com:view-projection-mode-parallel view-projection-mode-parallel)
                     (com:view-projection-mode-perspective view-projection-mode-perspective))
         
         ; misc
         join-shapes
         
         ; methods
         add-arc
         add-box
         add-circle
         add-cone
         add-cylinder
         add-edge-surface
         add-ellipse
         add-hatch
         add-interp-curve
         add-line
         add-loft-surface
         add-planar-surface
         add-point
         add-polyline
         add-sphere
         add-surface-coords
         
         boolean-difference
         boolean-intersection
         boolean-union
         
         cap-planar-holes
         close-curve
         copy
         create-solid
         
         delete
         delete-all
         
         duplicate-edge-curves
         duplicate-surface-border
         
         (rename-out (com:enable-redraw enable-redraw))
         
         extrude-curve
         extrude-curve-coord
         extrude-curve-straight
         extrude-surface
         
         get-object
         get-shapes
         intersect-breps
         object-in-box?
         
         join-curves
         join-surfaces
         
         move
         
         offset-surface
         offset-surface-solid
         
         render
         
         rotate
         scale
         surface-surface-intersection
         
         view
         
         world-xy-plane
         world-yz-plane
         world-zx-plane
         
         ; circle properties
         is-circle?
         circle-center
         circle-normal
         circle-radius
         
         ; curve properties
         is-curve?
         is-curve-closable?
         is-curve-closed?
         curve-end-coord
         curve-begin-coord
         
         ; object properties
         is-object?
         object-bounding-box
         
         ; polycurve properties
         is-polycurve?
         
         ; polysurface properties
         is-polysurface?
         
         ; surface properties
         is-surface?
         surface-domain
         surface-curvature
         
         ; solid properties
         is-object-solid?
         
         ; rhino
         add-layer
         current-layer
         delete-layer
         is-layer?
         layer=?)


; exception

(define-struct (marshall-exn exn:fail) ())

(define (raise-marshall-exn msg)
  (raise (make-marshall-exn msg (current-continuation-marks))))

(define add-hatch-msg
  "Trying to add a hatch to a shape that is not a curve")

(define (cap-planar-holes-msg shape)
  (format "Cap planar holes: shape must be a single surface, given ~A" shape))

(define circle-center-msg
  "Trying to get the center of a shape that is not a circle.")

(define circle-normal-msg
  "Trying to get the normal of a shape that is not a circle.")

(define circle-radius-msg
  "Trying to get the radius of a shape that is not a circle.")

(define (close-curve-msg shape)
  (format "Close curve: shape must be a single curve, given ~A" shape))

(define curve-begin-coord-msg
  "Trying to get the start coord of a shape that is not a curve.")

(define curve-end-coord-msg
  "Trying to get the end coord of a shape that is not a curve.")

(define (duplicate-edge-curves-msg shape)
  (format "Duplicate edge curves: shape must be a single surface, given ~A" shape))

(define (duplicate-surface-border-msg shape)
  (format "Duplicate surface offset: shape must be a single surface, given ~A" shape))

(define (extrude-curve-coord-msg shape)
  (format "Extrude curve coord: shape must be a single curve, given ~A" shape))

(define intersect-breps-msg
  "Trying to intersect two shapes that are not Breps")

(define surface-surface-intersection-msg
  "Trying to intersect two shapes that are not surfaces")


; loft

(define (loft-type s)
  (case s
    ('normal 0)
    ('loose 1)
    ('straight 2)
    ('tight 3)
    ('developable 4)
    (else
     (error 'loft-type "Unhandled loft type"))))

(define (loft-style s)
  (case s
    ('none 0)
    ('rebuild 1)
    ('refit 2)
    (else
     (error 'loft-style "Unhandled loft style"))))

; /loft

; info: incoherency: rhino returns nested planes but expects flat planes
(define (flat-plane<-matrix m)
  (vector-map
   real<-number
   (vector-append
    (vector-drop-right (m.column m 3) 1)
    (vector-drop-right (m.column m 0) 1)
    (vector-drop-right (m.column m 1) 1)
    (vector-drop-right (m.column m 2) 1))))

; info: incoherency: rhino returns nested planes but expects flat planes
(define (matrix<-nested-plane pl)
  (apply
   matrix<-cols
   (list-rotate-left (map vector->list (vector->list pl)) 1)))


; methods

(define (add-arc plane radius angle)
  (make-rhino-shape
   (com:add-arc
    (flat-plane<-matrix plane)
    (real<-number radius)
    (real<-number angle))))

(define (add-box corners)
  (make-rhino-shape
   (com:add-box
    (vector<real><-list<number> corners))))

(define (add-circle plane radius)
  (make-rhino-shape
   (com:add-circle
    (flat-plane<-matrix plane)
    (real<-number radius))))

(define (add-cone base height radius cap)
  (make-rhino-shape
   (com:add-cone
    (vector<real><-coord base)
    (vector<real><-coord height)
    (real<-number radius)
    cap)))

(define (add-cylinder base height radius cap)
  (make-rhino-shape
   (com:add-cylinder
    (vector<real><-coord base)
    (vector<real><-coord height)
    (real<-number radius)
    cap)))

(define (add-edge-surface shapes)
  (begin0
    (make-rhino-shape
     (com:add-edge-srf
      (vector<string><-list<shape> shapes)))
    (map delete shapes)))

(define (add-ellipse plane x-radius y-radius)
  (make-rhino-shape
   (com:add-ellipse
    (flat-plane<-matrix plane)
    (real<-number x-radius)
    (real<-number y-radius))))

(define (add-hatch shape)
  (if (is-curve? shape)
      (begin0
        (make-rhino-shape (com:add-hatch (rhino-shape-ids shape)))
        (delete shape))
      (raise-marshall-exn add-hatch-msg)))

(define add-interp-curve
  (case-lambda
    ((cs)
     (make-rhino-shape
      (com:add-interp-curve
       (flat-vector<real><-list<coord> cs))))
    ((cs begin-tangent end-tangent)
     (make-rhino-shape
      (com:add-interp-curve
       (flat-vector<real><-list<coord> cs)
       3
       com:knot-style-uniform-knots
       (vector-of-coord begin-tangent)
       (vector-of-coord end-tangent))))))

(define (add-line start-coord end-coord)
  (make-rhino-shape
   (com:add-line (vector-of-coord start-coord) (vector-of-coord end-coord))))

(define add-loft-surface
  (case-lambda
    ((shapes)
     (begin0
       (shape<-vector<string>
        (com:add-loft-surface
         (vector<string><-list<shape> shapes)))
       (map delete shapes)))
    ((shapes closed)
     (begin0
       (shape<-vector<string>
        (com:add-loft-surface
         (vector<string><-list<shape> shapes)
         closed))
       (map delete shapes)))
    ((shapes start end type style value closed)
     (begin0
       (shape<-vector<string>
        (com:add-loft-surface
         (vector<string><-list<shape> shapes)
         start
         end
         (loft-type type)
         (loft-style style)
         value
         closed))
       (map delete shapes)))))

(define (add-planar-surface shape)
  (begin0
    (shape<-vector<string>
     (com:add-planar-srf
      (vector<string><-shape shape)))
    (delete shape)))

(define (add-point c)
  (make-rhino-shape
   (com:add-point
    (vector<real><-coord c))))

(define (add-polyline coords)
  (make-rhino-shape
   (com:add-polyline
    (flat-vector<real><-list<coord> coords))))

(define (add-sphere center radius)
  (make-rhino-shape
   (com:add-sphere
    (vector<real><-coord center)
    (real<-number radius))))

(define (add-surface-coords coords)
  (make-rhino-shape
   (com:add-srf-pt
    (flat-vector<real><-list<coord> coords))))


; operations

(define (binary-boolean operation-fn shape1 shape2 delete)
  (let ((result (operation-fn
                 (vector<string><-shape shape1)
                 (vector<string><-shape shape2)
                 delete)))
    (if (void? result)
        result
        (shape<-vector<string> result))))

(define (boolean-difference shape1 shape2 delete)
  (binary-boolean com:boolean-difference shape1 shape2 delete))

(define (boolean-intersection shape1 shape2 delete)
  (binary-boolean com:boolean-intersection shape1 shape2 delete))

(define (boolean-union shape1 shape2 delete)
  (let ((result (com:boolean-union
                 (vector-append
                  (vector<string><-shape shape1)
                  (vector<string><-shape shape2))
                 delete)))
    (if (void? result)
        result
        (shape<-vector<string> result))))

(define (cap-planar-holes shape)
  (cond ((or (is-surface? shape) (is-polysurface? shape))
         (com:cap-planar-holes (singleton-id shape))
         shape)
        (else
         (raise-marshall-exn (cap-planar-holes-msg shape)))))

(define (close-curve shape)
  (if (or (is-curve? shape) (is-polycurve? shape))
      (com:close-curve (singleton-id shape))
      (raise-marshall-exn (close-curve-msg shape))))

(define (copy shape)
  (shape<-vector<string>
   (com:copy-objects
    (vector<string><-shape shape))))

(define (create-solid shapes delete?)
  (shape<-vector<string>
   (com:create-solid
    (vector<string><-list<shape> shapes)
    delete?)))

(define (delete shape)
  (map com:delete-object (list<-shape shape)))

(define (delete-all)
  (let ((objects (com:all-objects)))
    (unless (= (vector-length objects) 0)
      (com:delete-objects objects))))

(define (duplicate-edge-curves shape (select? #f))
  (if (singleton-shape? shape)
      (begin0
        (map
         make-rhino-shape
         (vector->list
          (com:duplicate-edge-curves (singleton-id shape) select?)))
        (delete shape))
      (raise-marshall-exn (duplicate-edge-curves-msg shape))))

(define (duplicate-surface-border shape)
  (if (singleton-shape? shape)
      (begin0
        (map
         make-rhino-shape
         (vector->list
          (com:duplicate-surface-border (singleton-id shape))))
        (delete shape))
      (raise-marshall-exn (duplicate-surface-border-msg shape))))

; edit: test if delete shape is necessary
(define (extrude-curve shape path)
  (begin0
    (make-rhino-shape
     (map
      (λ (shape-id) (com:extrude-curve shape-id path))
      (list<-shape shape)))
    (delete shape)))

(define (extrude-curve-coord shape coord)
  (if (is-curve? shape)
      (begin0
        (make-rhino-shape
         (com:extrude-curve-point (singleton-id shape) (vector-of-coord coord)))
        (delete shape))
      (raise-marshall-exn (extrude-curve-coord-msg shape))))

(define (extrude-curve-straight shape start-coord end-coord)
  (begin0
    (make-rhino-shape
     (map
      (λ (shape-id)
        (com:extrude-curve-straight
         shape-id
         (vector<real><-coord start-coord)
         (vector<real><-coord end-coord)))
      (list<-shape shape)))
    (delete shape)))

; edit: test if delete shape is necessary
(define (extrude-surface shape curve cap?)
  (begin0
    (make-rhino-shape
     (map
      (λ (shape-id) (com:extrude-surface shape-id curve cap?))
      (list<-shape shape)))
    (delete shape)))

(define (get-object str kind)
  (make-rhino-shape
   (com:get-object str kind)))

(define (get-shapes)
  (let ((objects (vector->list (com:all-objects))))
    (map make-rhino-shape objects)))

(define (intersect-breps shape1 shape2 (tolerance com:optional))
  (if (and (singleton-shape? shape1) (singleton-shape? shape2))
      (begin0
        (shape<-vector<string>
         (com:intersect-breps
          (singleton-id shape1)
          (singleton-id shape2)
          tolerance))
        (delete shape1)
        (delete shape2))
      (raise-marshall-exn intersect-breps-msg)))

(define (object-in-box? shape bbox)
  (let ((box (flat-vector<real><-bbox bbox)))
    (andmap
     (λ (id) (com:is-object-in-box? id box))
     (list<-shape shape))))      

(define (join-curves shapes delete?)
  (shape<-vector<string>
   (com:join-curves (vector<string><-list<shape> shapes) delete?)))

(define (join-surfaces shapes delete?)
  (make-rhino-shape
   (com:join-surfaces (vector<string><-list<shape> shapes) delete?)))

(define move
  (case-lambda
    ((shape translation)
     (shape<-vector<string>
      (com:move-objects
       (vector<string><-shape shape)
       (vector<real><-coord translation))))
    ((shape start end)
     (shape<-vector<string>
      (com:move-objects
       (vector<string><-shape shape)
       (vector<real><-coord start)
       (vector<real><-coord end))))))

(define (offset-surface shape distance)
  (begin0
    (make-rhino-shape
     (map
      (λ (object) (com:offset-surface object distance))
      (list<-shape shape)))
    (delete shape)))

(define (offset-surface-solid shape distance)
  (make-rhino-shape
   (append*
    (map
     (λ (object) (vector->list (script:offset-surface-solid-command object distance)))
     (list<-shape shape)))))

(define (render width height path)
  (com:create-preview-image path com:view-perspective (vector width height)))

(define (rotate shape coord angle axis copy?)
  (shape<-vector<string>
   (com:rotate-objects
    (vector<string><-shape shape)
    (vector<real><-coord coord)
    (real<-number angle)
    (vector<real><-coord axis)
    copy?)))

(define (scale shape origin scale copy)
  (shape<-vector<string>
   (com:scale-objects
    (vector<string><-shape shape)
    (vector<real><-coord origin)
    (vector<real><-coord scale)
    copy)))

(define (surface-surface-intersection shape1 shape2 (tolerance com:optional))
  (if (and (is-surface? shape1) (is-surface? shape2))
      (begin0
        (shape<-vector<string>
         (vector-ref
          (com:surface-surface-intersection
           (singleton-id shape1)
           (singleton-id shape2)
           tolerance
           #t)
          1))
        (delete shape1)
        (delete shape2))
      (raise-marshall-exn surface-surface-intersection-msg)))

(define (view center target perspective lens)
  (com:view-projection com:view-perspective perspective)
  (com:view-camera-lens com:view-perspective lens)
  (com:view-camera-target com:view-perspective (vector-of-coord center) (vector-of-coord target))
  (com:view-display-mode com:view-perspective com:view-display-mode-render-preview))

(define (world-xy-plane)
  (matrix<-nested-plane (com:world-xy-plane)))

(define (world-yz-plane)
  (matrix<-nested-plane (com:world-yz-plane)))

(define (world-zx-plane)
  (matrix<-nested-plane (com:world-zx-plane)))


; circle properties

(define (is-circle? shape)
  (and (singleton-shape? shape)
       (com:is-circle? (singleton-id shape))))

(define (circle-center shape)
  (if (is-circle? shape)
      (coord-of-vector (com:circle-center-point (rhino-shape-ids shape)))
      (raise-marshall-exn circle-center-msg)))

(define (circle-normal shape)
  (if (is-circle? shape)
      (coord-of-vector (com:circle-normal (rhino-shape-ids shape)))
      (raise-marshall-exn circle-normal-msg)))

(define (circle-radius shape)
  (if (is-circle? shape)
      (com:circle-radius (rhino-shape-ids shape))
      (raise-marshall-exn circle-radius-msg)))


; curve properties

(define (is-curve? shape)
  (and (singleton-shape? shape)
       (com:is-curve? (singleton-id shape))))

(define (is-curve-closable? shape)
  (and (singleton-shape? shape)
       (com:is-curve-closable? (singleton-id shape))))

(define (is-curve-closed? shape)
  (and (singleton-shape? shape)
       (com:is-curve-closed? (singleton-id shape))))

(define (curve-end-coord shape)
  (if (is-curve? shape)
      (com:curve-end-point (rhino-shape-ids shape))
      (raise-marshall-exn curve-end-coord-msg)))

(define (curve-begin-coord shape)
  (if (is-curve? shape)
      (com:curve-start-point (rhino-shape-ids shape))
      (raise-marshall-exn curve-begin-coord-msg)))


; object properties

(define (is-object? shape)
  (andmap com:is-object? (list<-shape shape)))

(define (object-bounding-box shape)
  (make-bbox
   (list<coord><-vector<vector<real>>
    (com:bounding-box (vector<string><-shape shape)))))


; polycurve properties

(define (is-polycurve? shape)
  (and (singleton-shape? shape)
       (com:is-polycurve? (singleton-id shape))))


; polysurface properties

(define (is-polysurface? shape)
  (and (singleton-shape? shape)
       (com:is-polysurface? (singleton-id shape))))


; solid properties

(define (is-object-solid? shape)
  (and (singleton-shape? shape)
       (com:is-object-solid? (singleton-id shape))))


; surface properties

(define (is-surface? shape)
  (and (singleton-shape? shape)
       (com:is-surface? (singleton-id shape))))

; edit: it only gets the first id from shape
(define (surface-domain shape dim)
  (vector->list
   (com:surface-domain (first (list<-shape shape)) dim)))

; edit: it only gets the first id from shape
(define (surface-curvature shape u v)
  (vector->list
   (com:surface-curvature
    (first (list<-shape shape))
    (vector (real<-number u) (real<-number v)))))


; rhino

(define (add-layer layer)
  (com:add-layer layer))

(define current-layer
  (case-lambda
    (()
     (com:current-layer))
    ((layer)
     (com:current-layer layer))))

(define (delete-layer layer)
  (com:delete-layer layer))

(define (is-layer? layer)
  (and (string? layer) (com:is-layer? layer)))

(define layer=? string=?)